Come “ricercare” una finestra tra quelle aperte in Windows

Questa procedura permette di “ndare alla ricerca” patendo da una finestra base (per esempio quella di background di Windows il cui handle è facilmente ricavabile -  attraverso l’utilizzo della API GetDesktopWindow (Public Declare Function GetDesktopWindow Lib "user32" Alias "GetDesktopWindow" () As Long), di una determinata finestra o sotto-finestra avente come caption il testo indicato come parametro di funzione. In ambiente Windows XP se si cerca una finestra con captino “Start” si può ottenere l’handle del bottone “START” della barra di controllo; di conseguenza è possibile cambiare il testo in esso contenuto.
Tip fornito dal Sig. S.Tubini

Option explicit

Private Declare Function GetWindow Lib "user32" Alias "GetWindow" (ByVal hwnd As Long, 
ByVal wCmd As Long) As Long
Public Declare Function GetDesktopWindow Lib "user32" () As Long
Public Declare Function lstrlen Lib "kernel32" Alias "lstrlenA" (ByVal lpString As String) As Long
Public Declare Function GetWindowTextLength Lib "user32" Alias 
"GetWindowTextLengthA" (ByVal hWnd As Long) As Long
Private Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hwnd As 
Long, ByVal lpString As String, ByVal cch As Long) As Long
Private Declare Function SetWindowText Lib "user32" Alias "SetWindowTextA" (ByVal hwnd As 
Long, ByVal lpString As String) As Long

Private Const GW_CHILD = 5
Private Const GW_HWNDNEXT = 2

Public Function SearchWindow(hWnd As Long, sCaption As String) As Long
On Local Error Resume Next
Dim H1 As Long, T As String, T23 As String
 
 H1 = GetWindow(hWnd, GW_CHILD)
 If H1 = 0 Then Exit Function
 T = FindWindowsText(H1)

 If T = sCaption Then
    SearchWindow = H1: Exit Function
 End If
 
 If GetWindow(H1, GW_CHILD) > 0 Then
   SearchWindow = SearchWindow(H1, sCaption)
   If SearchWindow <> 0 Then Exit Function
 End If

    Do
     
     H1 = GetWindow(H1, GW_HWNDNEXT)
     If H1 = 0 Then Exit Function
     T = FindWindowsText(H1)
     If T = sCaption Then
        SearchWindow = H1: Exit Function
     End If
        If GetWindow(H1, GW_CHILD) > 0 Then
            SearchWindow = SearchWindow(H1, sCaption)
            If SearchWindow <> 0 Then Exit Function
        End If
    Loop Until H1 = 0
End Function

Public Function FindWindowsText(hWnd As Long) As String
    FindWindowsText = String$(GetWindowTextLength(hWnd) + 1, vbNull)
    GetWindowText hWnd, FindWindowsText, Len(FindWindowsText)
    FindWindowsText = Left(FindWindowsText, lstrlen(FindWindowsText))
End Function

Public Function ChangeWindowsCaption (hWnd As Long,sTxt As String)
SetWindowText hWnd, sTxt
End Function

Un conto alla rovescia per arrestare il sistema

Un tip per spegnere il computer dopo un determinato periodo di tempo. In caso di chiusura del programma, esso risponderà come se il tempo fosse scaduto.
Per il corretto funzionamento si consiglia di inizializzare i due controlli timer con i seguenti valori di proprietà:

Timer_tempo  Intervallo 1000 / Enabled = False
Timer_controllo  Intervallo 200 / Enabled = True

Tip fornito dal Sig. M. Bruseghin

Private Sub Timer_tempo_Timer()
If lblTempos.Caption = 0 And lblTempom.Caption = 0 And lblTempoh.Caption = 0 Then
Timer_tempo.Enabled = False
Else
lblTempos.Caption = lblTempos.Caption - 1
End If

If lblTempos.Caption < 0 Then
lblTempom.Caption = lblTempom.Caption - 1
lblTempos.Caption = 59
End If

If lblTempom.Caption < 0 Then
lblTempoh.Caption = lblTempoh.Caption - 1
lblTempom.Caption = 59
End If

If lblTempoh.Caption < 0 Then
lblTempoh.Caption = 0
lblTempom.Caption = 59
End If

If lblTempoh.Caption = 0 Then
lblTempoh.Caption = 0
End If

If lblTempos.Caption = 0 Then
If lblTempom.Caption = 0 Then
If lblTempoh.Caption = 0 Then
Timer_tempo.Enabled = False
Form1.Show
MsgBox "Tempo scaduto!", vbOKOnly + vbExclamation, “Arresto sistema 
in corso…"
‘ per Windows 98
Shell ("C:\WINDOWS\RUNDLL.EXE user.exe,exitwindows")
‘per Windows XP
Shell ("C:\WINDOWS\RUNDLL32.EXE user,exitwindows")
End
End If
End If
End If
End Sub

Private Sub Timer_controllo_Timer()
If lblTempos.Caption = 0 And lblTempom.Caption = 0 And lblTempoh.Caption = 0 Then
cmdAccendi.Enabled = False
Else
If Timer_tempo.Enabled = False Then
cmdAccendi.Enabled = True
End If
End If
End Sub

‘codice dei vari CommandButton
Private Sub cmdAccendi_Click()
Timer_tempo.Enabled = True
cmdAccendi.Enabled = False
End Sub

Private Sub cmdStop_Click()
Timer_tempo.Enabled = False
If lblTempoh.Caption = 0 And lblTempom.Caption = 0 And lblTempos.Caption = 0 Then
cmdAccendi.Enabled = False
Else
cmdAccendi.Enabled = True
End If
End Sub

Private Sub cmdImpostaTime_Click()
If Timer_tempo.Enabled = False Then
cmdAccendi.Enabled = False
End If

If txtOra.Text > "24" Then
MsgBox "Il Timer dell'ora non è accettabile", vbOKOnly + vbCritical, "Errore MB 
TimeOut! 1.0"
txtOra.Text = ""
txtOra.SetFocus
Else
lblTempoh.Caption = txtOra.Text
End If

If txtMinuti.Text > "59" Then
MsgBox "Il Timer dei minuti non è accettabile", vbOKOnly + vbCritical, "Errore MB 
TimeOut! 1.0"
txtMinuti.Text = ""
txtMinuti.SetFocus
Else
lblTempom.Caption = txtMinuti.Text
End If

If txtSecondi.Text > "59" Then
MsgBox "Il Timer dei secondi non è accettabile", vbOKOnly + vbCritical, "Errore MB 
TimeOut! 1.0"
txtSecondi.Text = ""
txtSecondi.SetFocus
Else
lblTempos.Caption = txtSecondi.Text
End If

If txtOra.Text = "" Then
lblTempoh.Caption = 0
End If

If txtMinuti.Text = "" Then
lblTempom.Caption = 0
End If
If txtSecondi.Text = "" Then
lblTempos.Caption = 0
End If
End Sub

Private Sub optImpostazioni_Click()
txtOra.Enabled = False
txtMinuti.Enabled = False
txtSecondi.Enabled = False
cmdImpostaTime.Enabled = False
cmdStop.Enabled = False
End Sub

Private Sub Form_Unload(Cancel As Integer)
MsgBox "Chiusura non consentita", vbOKOnly + vbCritical, "Arresto sistema in corso..."
' per Windows 98
Shell ("C:\WINDOWS\RUNDLL.EXE user.exe,exitwindows")
'per Windows XP
Shell ("C:\WINDOWS\RUNDLL32.EXE user,exitwindows")
End
End Sub

Come copiare una lista di IP in un vettore

Spesso su internet si trovano lunghissime liste di IP (Internet Protocol). Volendo creare un programma per gestire tali indirizzi è comodo averli sotto forma di vettori. 
Il tip proposto prende in considerazione gli ip nella forma: 255.255.255.255:8080
prelevati da un controllo textbox e poi spezzettati in due array semplici: ip() e port()
Tip fornito dal Sig. S. Rinaldo

Private Sub Command1_Click()
    
    Dim temp() As String
    Dim ip()
    Dim port()
    Dim fine As Integer
    Dim i, j As Integer
    
    temp = Split(txtIP.Text, vbCrLf)
    j = -1
    
    For i = LBound(temp) To UBound(temp)
        fine = InStr(1, temp(i), ":")
        If ((fine > 7) And (fine < 17)) Then
            j = j + 1
            ReDim Preserve ip(j)
            ReDim Preserve port(j)
            
            ip(i) = Mid(temp(i), 1, fine - 1)
            port(i) = Mid(temp(i), fine + 1, Len(temp(i)))
        End If
    Next i
 
End Sub

Un semplice Server proxy 

Una semplice applicazione che funge da Server Proxy consentendo la condivisione e l'accesso ai documenti ipertestuali del WEB tra tutti i computer di una rete locale. Per poterlo utilizzare, all’interno del browser digitare: "http://IP_PROXY:8080/IPSERVER/pagina.htm 
Tip fornito dal Sig. M.Nicosia

Option Explicit
Dim i As Integer

Private Sub delay(interval As Single)
Dim s As Single
s = Timer
Do While Timer < (s + interval)
    DoEvents
Loop
End Sub

Private Sub parse(buffer As String, ByRef server As String, ByRef richiesta As String)
On Error Resume Next
Dim url As String
url = Left$(buffer, InStr(buffer, "HTTP/1.1") - 2)
url = Right$(url, Len(url) - 5)
If InStr(url, "/") = 0 Then
    server = url
    richiesta = "GET /"
Else
    server = Left$(url, InStr(url, "/") - 1)
    richiesta = "GET " & Right$(url, Len(url) - Len(server)) & vbCrLf
End If
End Sub

Private Sub Form_Load()
wskserver.LocalPort = 8080
wskserver.Listen
i = 0
End Sub

Private Sub wskconnect_DataArrival(Index As Integer, ByVal bytesTotal As Long)
On Error Resume Next
Dim buffer As String
Dim server As String
Dim richiesta As String
wskconnect(Index).GetData buffer
parse buffer, server, richiesta
Load wskweb(Index)
wskweb(Index).Connect server, 80
delay 1
wskweb(Index).SendData richiesta
End Sub

Private Sub wskconnect_SendComplete(Index As Integer)
wskconnect(Index).Close
wskweb(Index).Close
Unload wskconnect(Index)
Unload wskweb(Index)
End Sub

Private Sub wskserver_ConnectionRequest(ByVal requestID As Long)
i = i + 1
Load wskconnect(i)
wskconnect(i).Accept requestID
delay 1
End Sub

Private Sub wskweb_DataArrival(Index As Integer, ByVal bytesTotal As Long)
On Error Resume Next
Dim risposta As String
wskweb(Index).GetData risposta
wskconnect(Index).SendData risposta
End Sub

Come calcolare il crc32 di alcune tipologie di dati

La semplice applicazione Visual Basic permette di calcolare il CRC32 di una stringa, di una array di byte o di un file. Ricordiamo che il controllo del CRC32 consente, mediante una tecnica di codifica dei bit, di ottenere un elevato grado di protezione del messaggio in oggetto, grazie alla rilevazione di un'alta percentuale d’errori
Tip fornito dal Sig. S.Tubini

Option Explicit

Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, 
Source As Any, ByVal Length As Long)

Private crc32table(255) As Long
Private Crc32TableSet As Boolean

Public Sub CreateTable(Optional lPolinomio As Long = &HEDB88320)
  Dim I     As Long
  Dim j     As Long
  Dim lCrc  As Long
  
  For I = 1 To 255 Step 1
    lCrc = I
    j = 8
    For j = 1 To 8 Step 1
      If (lCrc And 1) Then
        lCrc = ((lCrc And &HFFFFFFFE) \ 2&) And &H7FFFFFFF
        lCrc = lCrc Xor lPolinomio
      Else
        lCrc = ((lCrc And &HFFFFFFFE) \ 2&) And &H7FFFFFFF
      End If
    Next
    crc32table(I) = lCrc
Next I
Crc32TableSet = True
End Sub

Public Function CalcCRC32(ByteArr() As Byte) As Long
  Dim I As Long
  Dim CRC32Val As Long
  Dim ArrLen As Long
  Dim LongBytes(3) As Byte
  If (Not Crc32TableSet) Then CreateTable
  CRC32Val = -1
  ArrLen = UBound(ByteArr())
  For I = 0 To ArrLen Step 1
      SplitLongValues CRC32Val, LongBytes(): LongBytes(3) = 0
      CRC32Val = crc32table((CRC32Val Xor ByteArr(I)) And &HFF)
      CRC32Val = CRC32Val Xor MergeLongValues(LongBytes())
  Next
  
  CalcCRC32 = CRC32Val
End Function

Public Function CalcCRC32FromString(sStr As String) As Long
Dim bArr() As Byte, I As Long

    If Len(sStr) > 0 Then
        ReDim bArr(0 To (Len(sStr) - 1)) As Byte
        For I = 1 To Len(sStr) Step 1
            bArr(I - 1) = Asc(Mid(sStr, I, 1))
        Next
         CalcCRC32FromString = CalcCRC32(bArr())
    End If
    
End Function

Public Function CalcCRC32FromFile(sFile As String) As Long
On Local Error Resume Next
Dim bArr() As Byte, I As Long, L As Long
    If FileLen(sFile) > 0 Then
        If Err <> 0 Then Err = 0: Exit Function
        ReDim bArr(0 To (FileLen(sFile) - 1)) As Byte
        L = FreeFile()
        Open sFile For Binary As L
            Get L, , bArr()
        Close L
        CalcCRC32FromFile = CalcCRC32(bArr())
    End If
End Function

Public Sub SplitLongValues(lValue As Long, ByteArr() As Byte)
   CopyMemory ByteArr(0), lValue, 4
End Sub

Public Sub SplitIntegerValues(iValue As Integer, ByteArr() As Byte)
    CopyMemory ByteArr(0), lValue, 2
End Sub

Public Function MergeLongValues(ByteArr() As Byte) As Long
    CopyMemory MergeLongValues, ByteArr(0), 4
End Function

Public Function MergeIntegerValues(ByteArr() As Byte) As Integer
    CopyMemory MergeIntegerValues, ByteArr(0), 2
End Function